home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / pcl-src.zoo / defsys.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1993-02-07  |  35.1 KB  |  898 lines
  1. ;;;-*-Mode:LISP; Package:(PCL LISP ); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27. ;;; Some support stuff for compiling and loading PCL.  It would be nice if
  28. ;;; there was some portable make-system we could all agree to share for a
  29. ;;; while.  At least until people really get databases and stuff.
  30. ;;;
  31. ;;; ***                                                               ***
  32. ;;; ***        DIRECTIONS FOR INSTALLING PCL AT YOUR SITE             ***
  33. ;;; ***                                                               ***
  34. ;;;
  35. ;;; To get PCL working at your site you should:
  36. ;;; 
  37. ;;;  - Get all the PCL source files from Xerox.  The complete list of source
  38. ;;;    file names can be found in the defsystem for PCL which appears towards
  39. ;;;    the end of this file.
  40. ;;; 
  41. ;;;  - Edit the variable *pcl-directory* below to specify the directory at
  42. ;;;    your site where the pcl sources and binaries will be.  This variable
  43. ;;;    can be found by searching from this point for the string "***" in
  44. ;;;    this file.
  45. ;;; 
  46. ;;;  - Use the function (pcl::compile-pcl) to compile PCL for your site.
  47. ;;; 
  48. ;;;  - Once PCL has been compiled it can be loaded with (pcl::load-pcl).
  49. ;;;    Note that PCL cannot be loaded on top of itself, nor can it be
  50. ;;;    loaded into the same world it was compiled in.
  51. ;;;
  52.  
  53. #+pcl
  54. (when (boundp 'pcl::*boot-state*)
  55.   (warn "Lisp heap already had PCL package.  Renaming it to OLD-PCL.")
  56.   (rename-package "PCL" "OLD-PCL"))
  57.  
  58. (in-package "PCL" :use (list (or (find-package :walker)
  59.                  (make-package :walker :use '(:lisp)))
  60.                  (or (find-package :iterate)
  61.                  (make-package :iterate
  62.                            :use '(:lisp :walker)))
  63.                  (find-package :lisp)))
  64.  
  65. (export (intern (symbol-name :iterate)        ;Have to do this here,
  66.         (find-package :iterate))    ;because in the defsystem
  67.     (find-package :iterate))        ;(later in this file)
  68.                         ;we use the symbol iterate
  69.                         ;to name the file
  70.  
  71. ;;;
  72. ;;; Sure, its weird for this to be here, but in order to follow the rules
  73. ;;; about order of export and all that stuff, we can't put it in PKG before
  74. ;;; we want to use it.
  75. ;;; 
  76. (defvar *the-pcl-package* (find-package :pcl))
  77.  
  78. (defvar *pcl-system-date* "July 92 PCL (1b)")
  79.  
  80. #+cmu
  81. (when (boundp 'ext::*herald-items*)
  82.   (setf (getf ext::*herald-items* :pcl)
  83.         `("    CLOS based on PCL version:  " ,*pcl-system-date*)))
  84.  
  85. ;;;
  86. ;;; Various hacks to get people's *features* into better shape.
  87. ;;; 
  88. (eval-when (compile load eval)
  89.   
  90.   #+(and Symbolics Lispm)
  91.   (multiple-value-bind (major minor) (sct:get-release-version)
  92.     (etypecase minor
  93.       (integer)
  94.       (string (setf minor (parse-integer minor :junk-allowed t))))
  95.     (pushnew :genera *features*)
  96.     (ecase major
  97.       ((6)
  98.        (pushnew :genera-release-6 *features*))
  99.       ((7)
  100.        (pushnew :genera-release-7 *features*)
  101.        (ecase minor
  102.      ((0 1) (pushnew :genera-release-7-1 *features*))
  103.      ((2)   (pushnew :genera-release-7-2  *features*))
  104.      ((3)   (pushnew :genera-release-7-3  *features*))
  105.      ((4)   (pushnew :genera-release-7-4  *features*))))
  106.       ((8)
  107.        (pushnew :genera-release-8 *features*)
  108.        (ecase minor
  109.      ((0) (pushnew :genera-release-8-0 *features*))
  110.      ((1) (pushnew :genera-release-8-1 *features*))))))
  111.   
  112.   #+CLOE-Runtime
  113.   (let ((version (lisp-implementation-version)))
  114.     (when (string-equal version "2.0" :end1 (min 3 (length version)))
  115.       (pushnew :cloe-release-2 *features*)))
  116.  
  117.   (dolist (feature *features*)
  118.     (when (and (symbolp feature)                ;3600!!
  119.                (equal (symbol-name feature) "CMU"))
  120.       (pushnew :CMU *features*)))
  121.   
  122.   #+TI
  123.   (if (eq (si:local-binary-file-type) :xld)
  124.       (pushnew ':ti-release-3 *features*)
  125.       (pushnew ':ti-release-2 *features*))
  126.  
  127.   #+Lucid
  128.   (when (search "IBM RT PC" (machine-type))
  129.     (pushnew :ibm-rt-pc *features*))
  130.  
  131.   #+ExCL
  132.   (cond ((search "sun3" (lisp-implementation-version))
  133.      (push :sun3 *features*))
  134.     ((search "sun4" (lisp-implementation-version))
  135.      (push :sun4 *features*)))
  136.  
  137.   #+(and HP Lucid)
  138.   (push :HP-Lucid *features*)
  139.   #+(and HP (not Lucid) (not excl))
  140.   (push :HP-HPLabs *features*)
  141.  
  142.   #+Xerox
  143.   (case il:makesysname
  144.     (:lyric (push :Xerox-Lyric *features*))
  145.     (otherwise (push :Xerox-Medley *features*)))
  146. ;;;
  147. ;;; For KCL and IBCL, push the symbol :turbo-closure on the list *features*
  148. ;;; if you have installed turbo-closure patch.  See the file kcl-mods.text
  149. ;;; for details.
  150. ;;;
  151. ;;; The xkcl version of KCL has this fixed already.
  152. ;;; 
  153.  
  154.   #+xkcl(pushnew :turbo-closure *features*)
  155.  
  156.   )
  157.  
  158.  
  159.  
  160. ;;; Yet Another Sort Of General System Facility and friends.
  161. ;;;
  162. ;;; The entry points are defsystem and operate-on-system.  defsystem is used
  163. ;;; to define a new system and the files with their load/compile constraints.
  164. ;;; Operate-on-system is used to operate on a system defined that has been
  165. ;;; defined by defsystem.  For example:
  166. #||
  167.  
  168. (defsystem my-very-own-system
  169.        "/usr/myname/lisp/"
  170.   ((classes   (precom)           ()                ())
  171.    (methods   (precom classes)   (classes)         ())
  172.    (precom    ()                 (classes methods) (classes methods))))
  173.  
  174. This defsystem should be read as follows:
  175.  
  176. * Define a system named MY-VERY-OWN-SYSTEM, the sources and binaries
  177.   should be in the directory "/usr/me/lisp/".  There are three files
  178.   in the system, there are named classes, methods and precom.  (The
  179.   extension the filenames have depends on the lisp you are running in.)
  180.   
  181. * For the first file, classes, the (precom) in the line means that
  182.   the file precom should be loaded before this file is loaded.  The
  183.   first () means that no other files need to be loaded before this
  184.   file is compiled.  The second () means that changes in other files
  185.   don't force this file to be recompiled.
  186.  
  187. * For the second file, methods, the (precom classes) means that both
  188.   of the files precom and classes must be loaded before this file
  189.   can be loaded.  The (classes) means that the file classes must be
  190.   loaded before this file can be compiled.  The () means that changes
  191.   in other files don't force this file to be recompiled.
  192.  
  193. * For the third file, precom, the first () means that no other files
  194.   need to be loaded before this file is loaded.  The first use of
  195.   (classes methods)  means that both classes and methods must be
  196.   loaded before this file can be compiled.  The second use of (classes
  197.   methods) mean that whenever either classes or methods changes precom
  198.   must be recompiled.
  199.  
  200. Then you can compile your system with:
  201.  
  202.  (operate-on-system 'my-very-own-system :compile)
  203.  
  204. and load your system with:
  205.  
  206.  (operate-on-system 'my-very-own-system :load)
  207.  
  208. ||#
  209.  
  210. ;;; 
  211. (defvar *system-directory*)
  212.  
  213. ;;;
  214. ;;; *port* is a list of symbols (in the PCL package) which represent the
  215. ;;; Common Lisp in which we are now running.  Many of the facilities in
  216. ;;; defsys use the value of *port* rather than #+ and #- to conditionalize
  217. ;;; the way they work.
  218. ;;; 
  219. (defvar *port*
  220.         '(#+Genera               Genera
  221. ;         #+Genera-Release-6     Rel-6
  222. ;         #+Genera-Release-7-1   Rel-7
  223.           #+Genera-Release-7-2   Rel-7
  224.       #+Genera-Release-7-3   Rel-7
  225.           #+Genera-Release-7-1   Rel-7-1
  226.           #+Genera-Release-7-2   Rel-7-2
  227.       #+Genera-Release-7-3   Rel-7-2    ;OK for now
  228.       #+Genera-Release-7-4   Rel-7-2    ;OK for now
  229.       #+Genera-Release-8     Rel-8
  230.       #+imach                Ivory
  231.       #+Cloe-Runtime     Cloe
  232.           #+Lucid                Lucid
  233.           #+Xerox                Xerox
  234.       #+Xerox-Lyric          Xerox-Lyric
  235.       #+Xerox-Medley         Xerox-Medley
  236.           #+TI                   TI
  237.           #+(and dec vax common) Vaxlisp
  238.           #+KCL                  KCL
  239.           #+IBCL                 IBCL
  240.           #+excl                 excl
  241.       #+(and excl sun4)      excl-sun4
  242.           #+:CMU                 CMU
  243.           #+HP-HPLabs            HP-HPLabs
  244.           #+:gclisp              gclisp
  245.           #+pyramid              pyramid
  246.           #+:coral               coral
  247.           #+CLISP                CLISP))
  248.  
  249. ;;;
  250. ;;; When you get a copy of PCL (by tape or by FTP), the sources files will
  251. ;;; have extensions of ".lisp" in particular, this file will be defsys.lisp.
  252. ;;; The preferred way to install pcl is to rename these files to have the
  253. ;;; extension which your lisp likes to use for its files.  Alternately, it
  254. ;;; is possible not to rename the files.  If the files are not renamed to
  255. ;;; the proper convention, the second line of the following defvar should
  256. ;;; be changed to:
  257. ;;;     (let ((files-renamed-p nil)
  258. ;;;
  259. ;;; Note: Something people installing PCL on a machine running Unix
  260. ;;;       might find useful.  If you want to change the extensions
  261. ;;;       of the source files from ".lisp" to ".lsp", *all* you have
  262. ;;;       to do is the following:
  263. ;;;
  264. ;;;       % foreach i (*.lisp)
  265. ;;;       ? mv $i $i:r.lsp
  266. ;;;       ? end
  267. ;;;       %
  268. ;;;
  269. ;;;       I am sure that a lot of people already know that, and some
  270. ;;;       Unix hackers may say, "jeez who doesn't know that".  Those
  271. ;;;       same Unix hackers are invited to fix mv so that I can type
  272. ;;;       "mv *.lisp *.lsp".
  273. ;;;
  274. (defvar *default-pathname-extensions*
  275.   (car '(#+(and (not imach) genera)          ("lisp"  . "bin")
  276.      #+(and imach genera)                ("lisp"  . "ibin")
  277.      #+Cloe-Runtime                      ("l"     . "fasl")
  278.      #+(and dec common vax (not ultrix)) ("LSP"   . "FAS")
  279.      #+(and dec common vax ultrix)       ("lsp"   . "fas")
  280.      #+KCL                               ("cl"   . "o")
  281.      #+IBCL                              ("lsp"   . "o")
  282.      #+Xerox                             ("lisp"  . "dfasl")
  283.      #+(and Lucid MC68000)               ("lisp"  . "lbin")
  284.      #+(and Lucid VAX)                   ("lisp"  . "vbin")
  285.      #+(and Lucid Prime)                 ("lisp"  . "pbin")
  286.      #+(and Lucid SUNRise)               ("lisp"  . "sbin")
  287.      #+(and Lucid SPARC)                 ("lisp"  . "sbin")
  288.      #+(and Lucid IBM-RT-PC)             ("lisp"  . "bbin")
  289.      #+(and Lucid MIPS)                  ("lisp"  . "mbin")
  290.      #+(and Lucid PRISM)                 ("lisp"  . "abin")
  291.      #+(and Lucid PA)                    ("lisp"  . "hbin")
  292.      #+excl                              ("cl"    . "fasl")
  293.      #+(and excl SPARC)                  ("cl"    . "sparc")
  294.      #+(and excl m68k (not next))        ("cl"    . "m68k")
  295.      #+excl                              ("cl"    . "fasl")
  296.          #+cmu ("lisp" . #.(c:backend-fasl-file-type c:*backend*))
  297.      #+HP-HPLabs                         ("l"     . "b")
  298.      #+TI ("lisp" . #.(string (si::local-binary-file-type)))
  299.      #+:gclisp                           ("LSP"   . "F2S")
  300.      #+pyramid                           ("clisp" . "o")
  301.      #+:coral                            ("cl"    . "fasl")
  302.          #+(and CLISP (or ATARI DOS))        ("LSP"   . "FAS")
  303.          #+(and CLISP (not (or ATARI DOS)))  ("lsp"   . "fas")
  304.        #-(or symbolics (and dec common vax) KCL IBCL Xerox 
  305.            lucid excl :CMU HP TI :gclisp pyramid coral CLISP)
  306.                                            ("lisp"  . "lbin"))))
  307.  
  308. (defvar *pathname-extensions*
  309.   (let* ((files-renamed-p t)
  310.      (proper-extensions *default-pathname-extensions*))
  311.     (cond ((null proper-extensions) '("l" . "lbin"))
  312.           ((null files-renamed-p) (cons "lisp" (cdr proper-extensions)))
  313.           (t proper-extensions))))
  314.  
  315. (eval-when (compile load eval)
  316.  
  317. (defun get-system (name)
  318.   (get name 'system-definition))
  319.  
  320. (defun set-system (name new-value)
  321.   (setf (get name 'system-definition) new-value))
  322.  
  323. (defmacro defsystem (name directory files)
  324.   `(set-system ',name (list #'(lambda () ,directory)
  325.                 (make-modules ',files)
  326.                 ',(mapcar #'car files))))
  327.  
  328. )
  329.  
  330.  
  331. ;;;
  332. ;;; The internal datastructure used when operating on a system.
  333. ;;; 
  334. (defstruct (module (:constructor make-module (name))
  335.                    (:print-function
  336.                      (lambda (m s d)
  337.                        (declare (ignore d))
  338.                        (format s "#<Module ~A>" (module-name m)))))
  339.   name
  340.   load-env
  341.   comp-env
  342.   recomp-reasons)
  343.  
  344. (defun make-modules (system-description)
  345.   (let ((modules ()))
  346.     (labels ((get-module (name)
  347.                (or (find name modules :key #'module-name)
  348.                    (progn (setq modules (cons (make-module name) modules))
  349.                           (car modules))))
  350.              (parse-spec (spec)
  351.                (if (eq spec 't)
  352.                    (reverse (cdr modules))
  353.            (case (car spec)
  354.              (+ (append (reverse (cdr modules))
  355.                 (mapcar #'get-module (cdr spec))))
  356.              (- (let ((rem (mapcar #'get-module (cdr spec))))
  357.               (remove-if #'(lambda (m) (member m rem))
  358.                      (reverse (cdr modules)))))
  359.              (otherwise (mapcar #'get-module spec))))))
  360.       (dolist (file system-description)
  361.         (let* ((name (car file))
  362.                (port (car (cddddr file)))
  363.                (module nil))
  364.           (when (or (null port)
  365.                     (member port *port*))
  366.             (setq module (get-module name))
  367.             (setf (module-load-env module) (parse-spec (cadr file))
  368.                   (module-comp-env module) (parse-spec (caddr file))
  369.                   (module-recomp-reasons module) (parse-spec (cadddr file))))))
  370.       (let ((filenames (mapcar #'car system-description)))
  371.     (sort modules #'(lambda (name1 name2)
  372.               (member name2 (member name1 filenames)))
  373.           :key #'module-name)))))
  374.  
  375.  
  376. (defun make-transformations (modules filter make-transform)
  377.   (let ((transforms (list nil)))
  378.     (dolist (m modules)
  379.       (when (funcall filter m transforms) (funcall make-transform m transforms)))
  380.     (reverse (cdr transforms))))
  381.  
  382. (defun make-compile-transformation (module transforms)
  383.   (unless (dolist (trans transforms)
  384.         (and (eq (car trans) ':compile)
  385.          (eq (cadr trans) module)
  386.          (return t)))
  387.     (dolist (c (module-comp-env module)) (make-load-transformation c transforms))
  388.     (setf (cdr transforms)
  389.       (remove-if #'(lambda (trans) (and (eq (car trans) :load)
  390.                         (eq (cadr trans) module)))
  391.              (cdr transforms)))
  392.     (push `(:compile ,module) (cdr transforms))))
  393.  
  394. (defvar *being-loaded* ())
  395.  
  396. (defun make-load-transformation (module transforms)
  397.   (if (assoc module *being-loaded*)
  398.       (throw module (setf (cdr transforms) (cdr (assoc module *being-loaded*))))
  399.       (let ((*being-loaded* (cons (cons module (cdr transforms)) *being-loaded*)))
  400.     (catch module
  401.       (unless (dolist (trans transforms)
  402.             (when (and (eq (car trans) ':load)
  403.                    (eq (cadr trans) module))
  404.               (return t)))
  405.         (dolist (l (module-load-env module))
  406.           (make-load-transformation l transforms))
  407.         (push `(:load ,module) (cdr transforms)))))))
  408.  
  409. (defun make-load-without-dependencies-transformation (module transforms)
  410.   (unless (dolist (trans transforms)
  411.             (and (eq (car trans) ':load)
  412.                  (eq (cadr trans) module)
  413.                  (return trans)))
  414.     (push `(:load ,module) (cdr transforms))))
  415.  
  416. (defun compile-filter (module transforms)
  417.   (or (dolist (r (module-recomp-reasons module))
  418.         (when (dolist (transform transforms)
  419.                 (when (and (eq (car transform) ':compile)
  420.                            (eq (cadr transform) r))
  421.                   (return t)))
  422.           (return t)))
  423.       (null (probe-file (make-binary-pathname (module-name module))))
  424.       (> (file-write-date (make-source-pathname (module-name module)))
  425.          (file-write-date (make-binary-pathname (module-name module))))))
  426.  
  427. (defun operation-transformations (name mode &optional arg)
  428.   (let ((system (get-system name)))
  429.     (unless system (error "Can't find system with name ~S." name))
  430.     (let ((*system-directory* (funcall (car system)))
  431.       (modules (cadr system)))
  432.       (ecase mode
  433.     (:compile
  434.       ;; Compile any files that have changed and any other files
  435.       ;; that require recompilation when another file has been
  436.       ;; recompiled.
  437.       (make-transformations
  438.        modules
  439.        #'compile-filter
  440.        #'make-compile-transformation))
  441.     (:recompile
  442.       ;; Force recompilation of all files.
  443.       (make-transformations
  444.        modules
  445.        #'true
  446.        #'make-compile-transformation))
  447.     (:recompile-some
  448.       ;; Force recompilation of some files.  Also compile the
  449.       ;; files that require recompilation when another file has
  450.       ;; been recompiled.
  451.       (make-transformations
  452.        modules
  453.        #'(lambda (m transforms)
  454.            (or (member (module-name m) arg)
  455.            (compile-filter m transforms)))
  456.        #'make-compile-transformation))
  457.     (:query-compile
  458.       ;; Ask the user which files to compile.  Compile those
  459.       ;; and any other files which must be recompiled when
  460.       ;; another file has been recompiled.
  461.       (make-transformations
  462.        modules
  463.        #'(lambda (m transforms)
  464.            (or (compile-filter m transforms)
  465.            (y-or-n-p "Compile ~A?"
  466.                  (module-name m))))
  467.        #'make-compile-transformation))
  468.     (:confirm-compile
  469.       ;; Offer the user a chance to prevent a file from being
  470.       ;; recompiled.
  471.       (make-transformations
  472.        modules
  473.        #'(lambda (m transforms)
  474.            (and (compile-filter m transforms)
  475.             (y-or-n-p "Go ahead and compile ~A?"
  476.                   (module-name m))))
  477.        #'make-compile-transformation))
  478.     (:load
  479.       ;; Load the whole system.
  480.       (make-transformations
  481.        modules
  482.        #'true
  483.        #'make-load-transformation))
  484.     (:query-load
  485.       ;; Load only those files the user says to load.
  486.       (make-transformations
  487.        modules
  488.        #'(lambda (m transforms)
  489.            (declare (ignore transforms))
  490.            (y-or-n-p "Load ~A?" (module-name m)))
  491.        #'make-load-without-dependencies-transformation))
  492.     (:compile-load
  493.       ;; Compile any files that have changed and any other files
  494.       ;; that require recompilation when another file has been
  495.       ;; recompiled.  But if nothing requires compilation,
  496.           ;; then load the whole system.
  497.       (make-compile-load-transformations
  498.         modules))))))
  499.  
  500. (defun true (&rest ignore)
  501.   (declare (ignore ignore))
  502.   't)
  503.  
  504. (defun operate-on-system (name mode &optional arg print-only)
  505.   (let ((system (get-system name)))
  506.     (unless system (error "Can't find system with name ~S." name))
  507.     (let* ((*system-directory* (funcall (car system)))
  508.        (transformations (operation-transformations name mode arg)))
  509.       (labels ((load-binary (name pathname)
  510.          (format t "~&Loading binary of ~A...~%" name)
  511.          (or print-only (load pathname)))           
  512.            (load-module (m)
  513.          (let* ((name (module-name m))
  514.             (*load-verbose* nil)
  515.             (binary (make-binary-pathname name)))
  516.            (load-binary name binary)))
  517.            (compile-module (m)
  518.          (format t "~&Compiling ~A...~%" (module-name m))
  519.          (unless print-only
  520.            (let  ((name (module-name m)))
  521.              (compile-file (make-source-pathname name)
  522.                    :output-file
  523.                    (make-pathname :defaults
  524.                           (make-binary-pathname name)
  525.                           :version :newest))))))
  526.     (#+Genera
  527.      compiler:compiler-warnings-context-bind
  528.      #+TI
  529.      COMPILER:COMPILER-WARNINGS-CONTEXT-BIND
  530.      #+:LCL3.0
  531.      lucid-common-lisp:with-deferred-warnings
  532.      #+cmu
  533.      with-compilation-unit #+cmu ()
  534.      #-(or Genera TI :LCL3.0 cmu)
  535.      progn
  536.            (loop (when (null transformations) (return t))
  537.          (let ((transform (pop transformations)))
  538.            (ecase (car transform)
  539.              (:compile (compile-module (cadr transform)))
  540.              (:load (load-module (cadr transform)))))))))))
  541.  
  542.  
  543. (defun make-source-pathname (name) (make-pathname-internal name :source))
  544. (defun make-binary-pathname (name) (make-pathname-internal name :binary))
  545.  
  546. (defun make-pathname-internal (name type)
  547.   (let* ((extension (ecase type
  548.                       (:source (car *pathname-extensions*))
  549.                       (:binary (cdr *pathname-extensions*))))
  550.          (directory (pathname
  551.               (etypecase *system-directory*
  552.             (string *system-directory*)
  553.             (pathname *system-directory*)
  554.             (cons (ecase type
  555.                 (:source (car *system-directory*))
  556.                 (:binary (cdr *system-directory*)))))))
  557.          (pathname
  558.            (make-pathname
  559.              :name #-(and CLISP (or ATARI DOS)) (string-downcase (string name))
  560.                    #+(and CLISP (or ATARI DOS))
  561.                    (let ((name (remove #\- (string-upcase (string name)))))
  562.                      (if (> (length name) 8) (subseq name 0 8) name)
  563.                    )
  564.              :type extension
  565.              :defaults directory)))
  566.  
  567.     #+Genera
  568.     (setq pathname (zl:send pathname :new-raw-name (pathname-name pathname))
  569.           pathname (zl:send pathname :new-raw-type (pathname-type pathname)))
  570.  
  571.     pathname))
  572.  
  573. (defun make-compile-load-transformations (modules)
  574.   (let ((transforms (list nil)))
  575.     (dolist (m modules)
  576.       (when (compile-filter m transforms)
  577.         (make-compile-transformation m transforms)))
  578.     (if (cdr transforms)
  579.         (reverse (cdr transforms))
  580.         (make-transformations
  581.         modules
  582.         #'true
  583.         #'make-load-transformation))))
  584.  
  585. (defun system-source-files (name)
  586.   (let ((system (get-system name)))
  587.     (unless system (error "Can't find system with name ~S." name))
  588.     (let ((*system-directory* (funcall (car system)))
  589.       (modules (cadr system)))
  590.       (mapcar #'(lambda (module)
  591.           (make-source-pathname (module-name module)))
  592.           modules))))
  593.  
  594. (defun system-binary-files (name)
  595.   (let ((system (get-system name)))
  596.     (unless system (error "Can't find system with name ~S." name))
  597.     (let ((*system-directory* (funcall (car system)))
  598.       (modules (cadr system)))
  599.       (mapcar #'(lambda (module)
  600.           (make-binary-pathname (module-name module)))
  601.           modules))))
  602.  
  603. ;;; ***                SITE SPECIFIC PCL DIRECTORY                        ***
  604. ;;;
  605. ;;; *pcl-directory* is a variable which specifies the directory pcl is stored
  606. ;;; in at your site.  If the value of the variable is a single pathname, the
  607. ;;; sources and binaries should be stored in that directory.  If the value of
  608. ;;; that directory is a cons, the CAR should be the source directory and the
  609. ;;; CDR should be the binary directory.
  610. ;;;
  611. ;;; By default, the value of *pcl-directory* is set to the directory that
  612. ;;; this file is loaded from.  This makes it simple to keep multiple copies
  613. ;;; of PCL in different places, just load defsys from the same directory as
  614. ;;; the copy of PCL you want to use.
  615. ;;;
  616. ;;; Note that the value of *PCL-DIRECTORY* is set using a DEFVAR.  This is
  617. ;;; done to make it possible for users to set it in their init file and then
  618. ;;; load this file.  The value set in the init file will override the value
  619. ;;; here.
  620. ;;;
  621. ;;; ***                                                                   ***
  622.  
  623. (defun load-truename (&optional (errorp nil))
  624.   #-(or Lispm excl Xerox (and dec vax common) LUCID akcl)
  625.   (declare (ignore errorp))
  626.   #-(or Lispm excl Xerox (and dec vax common) LUCID akcl) nil
  627.   #+(or Lispm excl Xerox (and dec vax common) LUCID akcl)
  628.   (flet ((bad-time ()
  629.        (when errorp
  630.          (error "LOAD-TRUENAME called but a file isn't being loaded."))))
  631.     #+Lispm  (or sys:fdefine-file-pathname (bad-time))
  632.     #+excl   excl::*source-pathname*
  633.     #+Xerox  (pathname (or (il:fullname *standard-input*) (bad-time)))
  634.     #+(and dec vax common) (truename (sys::source-file #'load-truename))
  635.     ;;
  636.     ;; The following use of  `lucid::' is a kludge for 2.1 and 3.0
  637.     ;; compatibility.  In 2.1 it was in the SYSTEM package, and i
  638.     ;; 3.0 it's in the LUCID-COMMON-LISP package.
  639.     ;;
  640.     #+LUCID (or lucid::*source-pathname* (bad-time))
  641.     #+akcl   si:*load-pathname*
  642.     ))
  643.  
  644.  
  645. #-(or cmu Symbolics CLISP)
  646. (defvar *pcl-directory*
  647.     (or (load-truename t)
  648.         (error "Because load-truename is not implemented in this port~%~
  649.                     of PCL, you must manually edit the definition of the~%~
  650.                     variable *pcl-directory* in the file defsys.lisp.")))
  651.  
  652. #+cmu
  653. (defvar *pcl-directory* (pathname "pcl:"))
  654.  
  655. #+coral
  656. (defvar *pcl-directory*
  657.         ;; Example MCL pathnames.
  658.         `(,(pathname "Harddisk0:MCL 2.0:July-92-PCL-beta:PCL Source:") 
  659.           . ,(pathname "Harddisk0:MCL 2.0:July-92-PCL-beta:PCL 1.3.2:")))
  660.  
  661. #+Genera
  662. (defvar *pcl-directory*
  663.     (let ((source (load-truename t)))
  664.       (flet ((subdir (name)
  665.            (scl:send source :new-pathname :raw-directory
  666.                  (append (scl:send source :raw-directory)
  667.                      (list name)))))
  668.         (cons source
  669.           #+genera-release-7-2       (subdir "rel-7-2")
  670.           #+genera-release-7-3       (subdir "rel-7-3") 
  671.           #+genera-release-7-4       (subdir "rel-7-4")
  672.           #+genera-release-8-0       (subdir "rel-8-0")
  673.           #+genera-release-8-1       (subdir "rel-8-1")
  674.           ))))
  675.  
  676. #+Cloe-Runtime
  677. (defvar *pcl-directory* (pathname "/usr3/hornig/pcl/"))
  678.  
  679. #+CLISP
  680. (defvar *pcl-directory*
  681.     (or (load-truename t)
  682.             (first (sys::search-file "defsys.lsp" nil))
  683.             #+UNIX            (pathname "~/lisp/pcl/")
  684.             #+(or ATARI DOS)  (pathname "\\LISP\\PCL\\")
  685. )       )
  686.  
  687.  
  688. (defsystem pcl       
  689.            *pcl-directory*
  690.   ;;
  691.   ;; file         load           compile      files which       port
  692.   ;;              environment    environment  force the of
  693.   ;;                                          recompilation
  694.   ;;                                          of this file
  695.   ;;                                          
  696.   (
  697. ;  (rel-6-patches   t            t            ()                rel-6)
  698. ;  (rel-7-1-patches t            t            ()                rel-7-1)
  699.    (rel-7-2-patches t            t            ()                rel-7-2)
  700.    (rel-8-patches   t            t            ()                rel-8)
  701.    (ti-patches      t            t            ()                ti)
  702.    (pyr-patches     t            t            ()                pyramid)
  703.    (xerox-patches   t            t            ()                xerox)
  704.    (kcl-patches     t            t            ()                kcl)
  705.    (ibcl-patches    t            t            ()                ibcl)
  706.    (gcl-patches     t            t            ()                gclisp)
  707.    
  708.    (pkg             t            t            ())
  709.    (sys-proclaim    t            t            ()                kcl)
  710.    (walk            (pkg)        (pkg)        ())
  711.    (iterate         t            t            ())
  712.    (macros          t            t            ())
  713.    (low             (pkg macros) t            (macros))
  714.    
  715.    
  716.    (genera-low     (low)         (low)        (low)            Genera)
  717.    (cloe-low       (low)     (low)          (low)            Cloe)
  718.    (lucid-low      (low)         (low)        (low)            Lucid)
  719.    (Xerox-low      (low)         (low)        (low)            Xerox)
  720.    (ti-low         (low)         (low)        (low)            TI)
  721.    (vaxl-low       (low)         (low)        (low)            vaxlisp)
  722.    (kcl-low        (low)         (low)        (low)            KCL)
  723.    (ibcl-low       (low)         (low)        (low)            IBCL)
  724.    (excl-low       (low)         (low)        (low)            excl)
  725.    (cmu-low        (low)         (low)        (low)            CMU)
  726.    (hp-low         (low)         (low)        (low)            HP-HPLabs)
  727.    (gold-low       (low)         (low)        (low)            gclisp) 
  728.    (pyr-low        (low)         (low)        (low)            pyramid) 
  729.    (coral-low      (low)         (low)        (low)            coral)
  730.    (clisp-low      (low)         (low)        (low)            CLISP)
  731.    
  732.    (fin         t                                   t (low))
  733.    (defclass    t                                   t (low))
  734.    (defs        t                                   t (defclass macros iterate))
  735.    (fngen       t                                   t (low))
  736.    (lap         t                                   t (low))
  737.    (plap        t                                   t (low))
  738.    (cpatch      t                                   t (low)    excl-sun4)
  739.    (quadlap     t                                   t (low)    excl-sun4)
  740.    (cache       t                                   t (low defs))
  741.    (dlap        t                                   t (defs low fin cache lap))
  742.    (boot        t                                   t (defs fin))
  743.    (defgenerics t                            t (boot))
  744.    (vector      t                                   t (boot defs cache fin))
  745.    (slots       t                                   t (vector boot defs low cache fin))
  746.    (init        t                                   t (vector boot defs low cache fin))
  747.    (std-class   t                                   t (vector boot defs low cache fin slots))
  748.    (str-class    t                                   t (vector boot defs low cache fin slots))
  749.    (cpl         t                                   t (vector boot defs low cache fin slots))
  750.    (braid       t                                   t (boot defs low fin cache))
  751.    (fsc         t                                   t (defclass boot defs low fin cache))
  752.    (methods     t                                   t (defclass boot defs low fin cache))
  753.    (combin      t                                   t (defclass boot defs low fin cache))
  754.    (dfun        t                                   t (dlap))
  755.    (fixup       (+ precom1 precom2)                 t (boot defs low fin))
  756.    (defcombin   t                                   t (defclass boot defs low fin))
  757.    (ctypes      t                                   t (defclass defcombin))
  758.    (construct   t                                   t (defclass boot defs low))
  759.    (env         t                                   t (defclass boot defs low fin))
  760.    (compat      t                                   t ())
  761.    (extensions  t                                   t ())
  762.    (precom1     (dlap)                              t (defs low cache fin dfun))
  763.    (precom2     (dlap)                              t (defs low cache fin dfun))
  764.    ))
  765.  
  766. (defun compile-pcl (&optional m)
  767.   (let (#+:coral(ccl::*warn-if-redefine-kernel* nil)
  768.     #+Lucid (lcl:*redefinition-action* nil)
  769.     #+excl  (excl::*redefinition-warnings* nil)
  770.     #+Genera (sys:inhibit-fdefine-warnings t)
  771.     )
  772.     (cond ((null m)        (operate-on-system 'pcl :compile))
  773.       ((eq m :print)   (operate-on-system 'pcl :compile () t))
  774.       ((eq m :query)   (operate-on-system 'pcl :query-compile))
  775.       ((eq m :confirm) (operate-on-system 'pcl :confirm-compile))
  776.       ((eq m 't)       (operate-on-system 'pcl :recompile))        
  777.       ((listp m)       (operate-on-system 'pcl :compile-from m))
  778.       ((symbolp m)     (operate-on-system 'pcl :recompile-some `(,m))))))
  779.  
  780. (defun load-pcl (&optional m)
  781.   (let (#+:coral(ccl::*warn-if-redefine-kernel* nil)
  782.     #+Lucid (lcl:*redefinition-action* nil)
  783.     #+excl  (excl::*redefinition-warnings* nil)
  784.     #+Genera (sys:inhibit-fdefine-warnings t)
  785.     )
  786.     (cond ((null m)      (operate-on-system 'pcl :load))
  787.       ((eq m :query) (operate-on-system 'pcl :query-load)))))
  788.  
  789. #+Genera
  790. ;;; Make sure Genera bug mail contains the PCL bug data.  A little
  791. ;;; kludgy, but what the heck.  If they didn't mean for people to do
  792. ;;; this, they wouldn't have made private patch notes be flavored
  793. ;;; objects, right?  Right.
  794. (progn
  795.   (scl:defflavor pcl-private-patch-info ((description)) ())
  796.   (scl:defmethod (sct::private-patch-info-description pcl-private-patch-info) ()
  797.     (or description
  798.     (setf description (string-append "PCL version: " *pcl-system-date*))))
  799.   (scl:defmethod (sct::private-patch-info-pathname pcl-private-patch-info) ()
  800.     *pcl-directory*)
  801.   (unless (find-if #'(lambda (x) (typep x 'pcl-private-patch-info))
  802.            sct::*private-patch-info*)
  803.     (push (scl:make-instance 'pcl-private-patch-info)
  804.       sct::*private-patch-info*)))
  805.  
  806. (defun bug-report-info (&optional (stream *standard-output*))
  807.   (format stream "~&PCL system date: ~A~
  808.                   ~&Lisp Implementation type: ~A~
  809.                   ~&Lisp Implementation version: ~A~
  810.                   ~&*features*: ~S"
  811.       *pcl-system-date*
  812.       (lisp-implementation-type)
  813.       (lisp-implementation-version)
  814.       *features*))
  815.  
  816.  
  817.  
  818. ;;;;
  819. ;;;
  820. ;;; This stuff is not intended for external use.
  821. ;;; 
  822. (defun rename-pcl ()
  823.   (dolist (f (cadr (get-system 'pcl)))
  824.     (let ((old nil)
  825.           (new nil))
  826.       (let ((*system-directory* *default-pathname-defaults*))
  827.         (setq old (make-source-pathname (car f))))
  828.       (setq new  (make-source-pathname (car f)))
  829.       (rename-file old new))))
  830.  
  831. #+Genera
  832. (defun edit-pcl ()
  833.   (dolist (f (cadr (get-system 'pcl)))
  834.     (let ((*system-directory* *pcl-directory*))
  835.       (zwei:find-file (make-source-pathname (car f))))))
  836.  
  837. #+Genera
  838. (defun hardcopy-pcl (&optional query-p)
  839.   (let ((files (mapcar #'(lambda (f)
  840.                            (setq f (car f))
  841.                            (and (or (not query-p)
  842.                                     (y-or-n-p "~A? " f))
  843.                                 f))
  844.                (cadr (get-system 'pcl))))
  845.         (b zwei:*interval*))
  846.     (unwind-protect
  847.         (dolist (f files)
  848.           (when f
  849.             (multiple-value-bind (ignore b)
  850.                 (zwei:find-file (make-source-pathname f))
  851.               (zwei:hardcopy-buffer b))))
  852.       (zwei:make-buffer-current b))))
  853.  
  854.  
  855. ;;;
  856. ;;; unido!ztivax!dae@seismo.css.gov
  857. ;;; z30083%tansei.cc.u-tokyo.junet@utokyo-relay.csnet
  858. ;;; Victor@carmen.uu.se
  859. ;;; mcvax!harlqn.co.uk!chris@uunet.UU.NET
  860. ;;; 
  861. #+Genera
  862. (defun mail-pcl (to)
  863.   (let* ((original-buffer zwei:*interval*)
  864.      (*system-directory* (pathname "vaxc:/user/ftp/pub/pcl/")
  865.                 ;(funcall (car (get-system 'pcl)))
  866.                  )
  867.          (files (list* 'defsys
  868.             'test
  869.             (caddr (get-system 'pcl))))
  870.          (total-number (length files))
  871.          (file nil)
  872.      (number-of-lines 0)
  873.          (i 0)
  874.          (mail-buffer nil))
  875.     (unwind-protect
  876.         (loop
  877.            (when (null files) (return nil))
  878.            (setq file (pop files))
  879.            (incf i)
  880.            (multiple-value-bind (ignore b)
  881.                (zwei:find-file (make-source-pathname file))
  882.          (setq number-of-lines (zwei:count-lines b))
  883.              (zwei:com-mail-internal t
  884.                                      :initial-to to
  885.                                      :initial-body b
  886.                      :initial-subject
  887.                                      (format nil
  888.                        "PCL file   ~A   (~A of ~A) ~D lines"
  889.                        file i total-number number-of-lines))
  890.              (setq mail-buffer zwei:*interval*)
  891.              (zwei:com-exit-com-mail)
  892.              (format t "~&Just sent ~A  (~A of ~A)." b i total-number)
  893.              (zwei:kill-buffer mail-buffer)))
  894.       (zwei:make-buffer-current original-buffer))))
  895.  
  896.  
  897.  
  898.